COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 A Metering System for MacLisp
C00017 00003	 Here's a typical file:
C00021 ENDMK
C⊗;
;;; A Metering System for MacLisp

(declare (special meter:meters meter:max meter:comments meter:meterp
		  meter:max-max meter:maxf meter:factor meter:array-name
		  meter:array-size meter:start-time meter:end-time meter:inc-only
		  meter:all-comments meter:local-max meter:real-runtime
		  meter:comment-name meter:fun-names meter:name)
	 (mapex t)
	 (flonum meter:real-runtime)
	 (fixnum meter:max-max meter:max)) 

(eval-when (compile eval)
	   (setq meter:meters () meter:fun-names ()
		 meter:all-comments () meter:comments ()))

(eval-when (load)
	   (cond ((boundp 'meter:meters))
		 (t (setq meter:meters ()))))

;;; (meter (defun foo ... (m "Baz"))...)
;;; (m "Foo") 	adds 1 to the "Foo" counter
;;; (m "Foo" 3) adds 3 to the "Foo" counter
;;; (m "Foo" 3 (foo a b c)) adds 3 to the "Foo" counter and counts the runtime
;;; (mn "Foo" foo) adds 1 to the foo counter
;;; (mn "Foo" foo 3) adds 3 to the foo counter
;;; (mn "Foo" foo 3 (foo a b c)) adds 3 to the foo counter and counts the runtime
;;;	in all cases the counts are listed as "Foo"
;;;  the indexed ones (mn ...) are so that PUSH can be counted as a CONS.

;;;						      the index for this entry
;;;							 |
;;;							 | number to increment by
;;; (meter-funs						 ↓   ↓
;;;  ((zerop "Zerop")(1- "1-") (* "Times")(PUSH "CONSs" CONS 2))
;;; 		  (defun fact (n)			 ↑   ↑ 
;;; 			 (cond ((zerop n) 1)		optionals
;;; 			       (t (* n (fact (1- n)))))))

;;; THE FILE MUST LOOK LIKE:
;;; (FASLOAD METER FAS DSK (TIM LSP))
;;; (METER:METER <name>
;;;   <contents of your file>)

(defun meter:make-name (symbol)
       (implode (append (explode symbol)
			'(-)
			(explode meter:name))))

(defmacro meter:meter (name . forms)
	  (setq meter:name name)
	  (setq meter:maxf (meter:make-name 'meter:maxf)
		meter:array-name (meter:make-name 'meter:array-name)
		meter:array-size (meter:make-name 'meter:array-size)
		meter:factor (meter:make-name 'meter:factor)
		meter:comment-name (meter:make-name 'meter:comment-name)
		meter:max-max 0)
	  (set  meter:comment-name
		(implode (append '(m e t e r :)
				 (explode name)
				 '(- c o m m e n t))) )
	  (set meter:array-name
	       (implode (append '(m e t e r :)
				(explode name) 
				'(- a r r a y))))
	  (set meter:maxf -1)
	  (setq meter:start-time (meter:make-name 'meter:start-time)
	        meter:end-time (meter:make-name 'meter:end-time)
		meter:inc-only (meter:make-name 'meter:inc-only))
	  (setq meter:fun-names ()
		meter:all-comments ()
		meter:comments ())
	  (let ((forms (mapcar #'meter:pass2 
			       (prog1
				(mapcan #'meter:pass1 forms)
				(set meter:factor (1+ meter:max-max))))))
	       (set meter:array-size (* (1+ (symeval meter:maxf))
					(1+ meter:max-max)))
	       `(progn 'compile 
		       (declare (array* (notype ,(symeval meter:comment-name)
						2)
					(fixnum ,(symeval meter:array-name)
						1))
				(fixnum ,meter:factor 
					,meter:array-size)
				(special ,meter:factor 
					 ,meter:array-size 
					 ,meter:array-name
					 ,meter:maxf 
					 ,meter:comment-name
					 meter:real-runtime)
				(*expr ,(meter:make-name 'meter:start-time)
				       ,(meter:make-name 'meter:end-time) ))
		       (array ,(symeval meter:comment-name) t 
			      ,(+ 2 (symeval meter:maxf))
			      ,(+ 2 meter:max-max))
		       (setq ,(meter:make-name 'meter:array-size)
			     ,(* (1+ (symeval meter:maxf))
				 (1+ meter:max-max)))
		       (array ,(symeval meter:array-name)
			      fixnum ,(1+ (symeval meter:maxf)))
		       (do ((i ,(symeval meter:maxf) (1- i)) 
			    (a (quote ,meter:fun-names) (cdr a))
			    (b (quote ,meter:all-comments) (cdr b)))
			   ((< i 0) ())
			   (store (,(symeval meter:comment-name) i 0) 
				  (car a))
			   (store (,(symeval meter:array-name) i)
				  (cadr (assq (car a) ',meter:meters)))
			   (do ((j 1 (1+ j))
				(c (reverse (car b)) (cdr c)))
			       ((null c) ())
			       (store (,(symeval meter:comment-name) i j) 
				      (cadr (car c))))) 
		       (setq ,meter:factor
			     ,(1+ meter:max-max))
		       (setq ,meter:array-name
			     (quote ,(symeval meter:array-name))
			     ,meter:maxf ,(symeval meter:maxf)
			     ,meter:comment-name 
			     (quote ,(symeval meter:comment-name)))
		       ,@forms
		       (include "metaux.lsp[tim,lsp]"))))

(defun meter:pass1 (form)
       (cond ((atom form) `(,form))
	     (t (caseq (car form)
		       (meter-funs
			(cond ((and (boundp 'meter:meterp)
				    (not meter:meterp))
			       (cdr form))
			      (t
			       (let ((funs (cadr form)))
				    (meter:pass1-a
				     (mapcar 
				      #'(lambda (f) 
						`(defun ,(cadr f) ,(caddr f)
							.,(meter:meter-funs funs 
									    (cdddr f))))
				      (cddr form)))))))
		       (meter
			(cond ((and (boundp 'meter:meterp)
				    (not meter:meterp))
			       (cdr form))
			      (t
			       (meter:pass1-a (cdr form)))))
		       (t `(,form)))))) 

(defun meter:pass1-a (funs)
       (let ((name (cadr (car funs))))
	    (set meter:maxf (1+ (symeval meter:maxf)))
	    (setq meter:max -1)
	    (prog1
	     (mapcar #'(lambda (f)
			       `(defun
				 ,(cadr f)
				 ,(caddr f)
				 .,(meter:process 
				    meter:array-name 
				    (cdddr f))))
		     funs)
	     (push name meter:fun-names)
	     (push 
	      meter:comments
	      meter:all-comments)
	     (setq meter:comments ())
	     (let ((entry (assq name meter:meters)))
		  (cond (entry (rplaca (cdr entry) meter:max))
			(t 
			 (push 
			  `(,name ,meter:max)
			  meter:meters))))
	     (setq meter:max-max (max meter:max-max meter:max)))))

(defun meter:pass2 (fun)
 (meter:pass2-a fun) fun))

(defun meter:pass2-a (fun)
       (cond ((null fun) ())
	     ((atom fun) ())
	     ((numberp fun) ())
	     ((or (eq (car fun) meter:end-time)
		  (eq (car fun) meter:inc-only))
	      (rplacd fun `(,(+ (* (symeval meter:factor) (cadr fun))
				(caddr fun)) ,(cadddr fun))))
	     (t (mapc #'meter:pass2-a fun))))

(defun meter:meter-funs (l f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     (t (let ((entry (assq (car f) l)))
		     (cond (entry
			    `(mn ,(cadr entry) ,(or (caddr entry)
						    (car entry))
				 ,(or (cadddr entry) 1)
				 ,(meter:meter-funs-nl l f)))
			   ((eq (car f) 'store)
			    `(store ,(cadr f) ,(meter:meter-funs l (caddr f))))
			   ((eq (car f) 'quote) f)
			   (t (mapcar #'(lambda (f)
					 (meter:meter-funs l f))
				      f)))))))

(defun meter:meter-funs-nl (l f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((eq (car f) 'store)
	      `(store ,(cadr f) ,(meter:meter-funs l (caddr f))))
	     ((eq (car f) 'quote) f)
	     (t (mapcar #'(lambda (f)
				  (meter:meter-funs l f))
			f))))

(defun meter:process (a f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((eq (car f) 'm)
	      (let* ((form ())
		     (inc (cond ((null (cddr f)) 1)
				((null (cdddr f))
				 (caddr f))
				(t 
				 (setq form (cadddr f))
				 (caddr f)))))
		    (setq meter:max (1+ meter:max))
		    (push `(() ,(cadr f)
			       ,(symeval meter:maxf) ,meter:max
			       ,inc)
			  meter:comments)
		    (cond (form
			   `(prog2 (,meter:start-time)
				   ,(meter:process a form)
				   (,meter:end-time
				    ,(symeval meter:maxf)
				    ,meter:max ,inc))) 
			  (t `(,meter:inc-only ,(symeval meter:maxf)
					      ,meter:max ,inc)))))
	     ((eq (car f) 'mn)
	      (let* ((index (caddr f))
		     (entry (assq index meter:comments))
		     (form ())
		     (inc (cond ((null (cdddr f)) 1)
				((null (cdr (cdddr f)))
				 (caddr (cdr f)))
				(t 
				 (setq form (cadddr (cdr f)))
				 (caddr (cdr f)))))
     		     (args
		      (cond (entry 
			     (cddr entry))
			    (t (setq meter:max (1+ meter:max))
			       (push `(,index ,(cadr f)
					      ,(symeval meter:maxf)
					      ,meter:max ,inc)
				     meter:comments)
			       `(,(symeval meter:maxf) ,meter:max ,inc)))))
		    (cond (form
			   `(prog2 (,meter:start-time) ,(meter:process a form)
				   (,meter:end-time .,args)))
			  (t `(,meter:inc-only .,args)))))
	     ((eq (car f) 'store)
	      `(store ,(cadr f) ,(meter:process a (caddr f))))
	     ((eq (car f) 'quote) f)
	     (t (mapcar #'(lambda (f) (meter:process a f))
			f))))

(defun meter:unprocess (f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((atom (car f))
	      `(,(car f) . ,(meter:unprocess (cdr f))))
	     ((eq (caar f) 'm)
	      (let ((form 
		      (cond ((null (cddr (car f))) ())
			    ((null (cdddr (car f)))
				 ())
			    (t 
			     (cadddr (car f)))))) 
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     ((eq (caar f) 'mn)
	      (let ((form
		     (cond ((null (cdddr (car f))) ())
			   ((null (cdr (cdddr (car f))))
			    ())
			   (t 
			    (cadddr (cdr (car f)))))))
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     (t `(,(meter:unprocess (car f))
		  . ,(meter:unprocess (cdr f))))))

;;; Here's a typical file:

;(declare 
; (fasload meter fas))
;
;(meter:meter baz
;	     (meter-funs ((+ "+'s")(= "='s")(foo "Calls to FOO"))
;			 (defun baz (n)
;				(do ((n n (1- n))
;				     (a 0))
;				    ((= n 0) a)
;				    (foo n)
;				    (setq a (+ a n)))) )
; 	     (meter-funs ((+ "+'s")(= "='s"))
;			 (defun foo (n)
;				(do ((n n (1- n))
;				     (a 0))
;				    ((= n 0) a)
;				    (setq a (+ a n))))))